home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM BV3 / BMUG PD-ROM Version BV3 (CDRM1097900).iso / Programming / Programming Languages / Pocket Forth 6 / Examples / Reader < prev    next >
Encoding:
Text File  |  1992-05-07  |  14.9 KB  |  365 lines  |  [TEXT/McSk]
  1. ( Reader application for Pocket Forth 0.6 )
  2. : RTEST ( -- ) key 13 = 0= IF bye ?terminal drop THEN ;
  3. page
  4. ( *******************  W A R N I N G  ******************** )
  5. (   This file creates the ReadMe application. Do NOT run   )
  6. ( this file on a normal copy of Pocket Forth. Instead make )
  7. ( a SPECIAL copy using ResEdit:                            )
  8. (   1} Open a copy of ReadMe with ResEdit                  )
  9. (   2} Delete the DICT 257 resource from ReadMe            )
  10. (   3} Open a copy of Pocket Forth with ResEdit            )
  11. (   4} Copy the DICT 257 resource from Pocket Forth        )
  12. (   5} Paste the DICT 257 resource into ReadMe             )
  13. (   6} Save ReadMe with ResEdit                            )
  14. (   7} Quit ResEdit and Open ReadMe                        )
  15. (   8} Type "open" and open Reader                         )
  16. (   9} Press the return key, wait until ReadMe quits.      )
  17. (  10} Restart ReadMe.                                     )
  18. (  Type return to continue, anything else to quit. )  rtest
  19. 0 28 +md !  ( shut off screen echo )
  20. forget task : task ;
  21.  
  22. : !FONT ( n -- ) >r ,$ A887 ;  ( _TextFont )
  23. : !FSIZE ( n -- ) >r ,$ A88A ;  ( _TextSize )
  24. : !FACE ( face -- ) >r ,$ A888 ; ( _TextFace )
  25. : SFONT ( -- ) 0 !font  12 !fsize ;  ( 12 point Chicago )
  26. : CLS ( -- ) 4 +md a>r ,$ A8A3  20 20 !pen ;  ( CLear Screen )
  27.  
  28. ( polygon handle storage )
  29. 2variable APOLY  ( aft button dpoly handle )
  30. 2variable FPOLY  ( fore button poly handle )
  31.  
  32. : ?PHIT ( h v poly -- flag ) ( true if h,v is in polyBBox )
  33.     0 >r  2@ dl@  2 0 d+  2swap 2>r  2>r ,$ A8AD r> ;  ( _PtInRect )
  34.  
  35. ( create polygons )
  36. : *POLY ( addr -- ) 0 0 2>r ,$ A8CB 2r> rot 2! ;  ( _OpenPoly )
  37. : *APOLY ( -- ) apoly *poly
  38.     5 225 !pen 20 210 -to 50 210 -to
  39.     50 240 -to 20 240 -to  5 225 -to  ,$ A8CC ;  ( _ClosePgon )
  40. : *FPOLY ( -- ) fpoly *poly
  41.     440 225 !pen 425 210 -to 390 210 -to
  42.     390 240 -to  425 240 -to 440 225 -to  ,$ A8CC ;  ( _ClosePgon )
  43.  
  44. ( print polygon )
  45. : .POLY ( addr -- ) 2@ 2>r ,$ A8C6 ;  ( _FramePoly )
  46. : .AARROW ( -- ) 015 230 !pen ." Prev"  apoly .poly ;
  47. : .FARROW ( -- ) 396 230 !pen ." Next"  fpoly .poly ;
  48. : .ARROWS ( -- ) .aarrow .farrow ;
  49.       
  50. ( print PICT resources from this file )
  51. : GETPICT ( id -- dhandle ) 0 0 2>r  >r  ,$ A9BC  2r> ;  ( _GetPict )
  52. : DPICT ( rect id -- ) GetPict  ( -- pictures.handle )
  53.     2dup 2>r rot a>r ,$ A8F6 ;  ( _DrawPicture )
  54.  
  55. ( rect words )
  56. : RECT ( compile: -- ) ( run: -- addr ) variable 6 allot ;
  57. : !RECT ( t l b r rect -- ) >r  swap r 4 + 2!  swap r> 2! ;
  58. : @RECT ( rect -- t l b r ) dup 2@ swap  rot 4 + 2@ swap ;
  59. : ROFFSET ( h v rect -- ) a>r 2>r ,$ A8A8 ;  ( _OffsetRect )
  60. : RINSET ( h v rect -- ) a>r 2>r ,$ A8A9 ;  ( _InsetRect )
  61. : ?IN ( h v rect -- flag ) ( true if h,v is in rect at addr )
  62.     0 >r  rot rot 2>r  a>r  ,$ A8AD r> ;  ( _PtInRect )
  63. : ?EMPTY ( rect -- flag ) 0 >r a>r ,$ A8AE r> ;  ( _EmptyRect )
  64. : RERASE ( rect -- ) a>r ,$ A8A3 ;  ( _EraseRect )
  65.  
  66. ( rects for pictures )
  67. rect PRECT  15 48 212 405 prect !rect  ( title picture rect )
  68. rect SRECT  192 222 221 370 srect !rect  ( signature rect )
  69.  
  70. : SCR ( -- ) @pen swap drop 16 + 50 swap !pen ;  ( special cr )
  71.  
  72. ( P1 - P? are page drawing routines.  They have no stack effect.)
  73. : P1  cls  prect 4000 dpict
  74.     50 30 !pen ." NEW!"  .farrow ;
  75.  
  76. : P2  cls scr
  77.     ."       Its FAST, its FUN and its FREE!" scr scr
  78.     ."    Pocket Forth, release 6, is a programming" scr
  79.     ."  language for writing Macintosh applications." cr scr
  80.     ."    You can take advantage of many new features" scr
  81.     ."  in this release such as Apple Events*, Floating" scr
  82.     ."  Point, Gestalt** and Drag & Drop* programming." cr scr
  83.     ."    I hope you have fun with Pocket Forth, and" scr
  84.     ."  maybe even " 2 !face ." use  " 0 !face ." it for something."
  85.     scr scr scr ."            * System 7   ** System 6.0.7+"
  86.     srect 4001 dpict  ( draw signature picture )
  87.     .arrows ;
  88.  
  89. : P3  cls scr
  90.     ."   Code produced by Pocket Forth is compact and fast." cr scr
  91.     ."   Since Pocket Forth produces true machine code," scr
  92.     ." you have complete control over your program." cr scr
  93.     ."   Examine and run the example programs for" scr
  94.     ." programming suggestions." cr scr
  95.     ."    If you have system 7 you can load text files by" scr
  96.     ."  dragging a text file icon onto Pocket Forth's icon." cr scr
  97.     ."  Older systems can use the menu to “Open” a file."
  98.     .arrows ;
  99.  
  100. : P4  cls scr
  101.     ."   Print and read the Manual and the Glossary." cr scr
  102.     ."   The Manual consists of two TeachText documents" scr
  103.     ." suitable for use as a reference to Pocket Forth" scr
  104.     ." for old hats and as a supplement to Brodie's" scr
  105.     4 !face ." Starting FORTH" 0 !face ."  for new Forthers." cr scr
  106.     ."   The Glossary, also a TeachText document, is a" scr
  107.     ." list of the words in the Pocket Forth dictionary." scr
  108.     ." Stack effects, pronounciation and usage are shown."
  109.     .arrows ;
  110.  
  111. : P5  cls scr
  112.     ." Major changes since release 5:" scr scr
  113.     ."  • Floating point numbers!" cr scr
  114.     ."    Numeric input containing a decimal point is" scr
  115.     ."    interpreted as an extended floating point" scr
  116.     ."    number. Floating Point numbers are kept on" scr
  117.     ."    the stack as ten byte entities."  cr scr
  118.     ."    SANE is used along with three dozen new" scr
  119.     ."    words that manipulate floating point numbers." cr scr scr
  120.     ."                                ( continued ... )"
  121.     .arrows ;
  122.  
  123. : P6  cls scr
  124.     ." Floating point continued ..." cr scr
  125.     ."    Stack words:      "  2 !face
  126.                            ." fdrop   fdup   fswap   fpick" scr
  127.     ."                               fpack   froll   f>d   d>f" cr scr
  128.     0 !face ."    Memory words: " 2 !face ." f@   f!   fliteral   f," scr
  129.     ."                               fconstant   fvariable" cr scr
  130.     0 !face ."    I/O words:         " 2 !face
  131.                                     ." fnumber   sci   fix   f." cr scr
  132.     0 !face ."    Math words:      " 2 !face
  133.                                     ." fcompare   f+   f-   f*   f/" scr
  134.     ."                               frem   f^   fint   fabs   fsqrt" scr
  135.     ."                               fsin   fcos   ftan   fatn" scr
  136.     ."                               fexp   fln"  0 !face
  137.     .arrows ;
  138.  
  139. : P7  cls scr
  140.     ."  • Define and install Apple Events:" cr scr
  141.     ."    Apple Events, the standard interface for" scr
  142.     ."    inter-application communications, are supported" scr
  143.     ."    by Pocket Forth. The four required events are" scr
  144.     ."    installed automatically, and you can define" scr
  145.     ."    your own Apple Event handlers." cr scr
  146.     ."    System 7 (or more) is required to use" scr
  147.     ."    Apple Events." scr scr scr
  148.     ."                                ( continued ... )"
  149.     .arrows ;
  150.  
  151.  
  152. : P8  cls scr
  153.     ." New words and variables control Apple Events:" cr scr
  154.     2 !face ."    AE:  " 0 !face ." and " 2 !face ." AE:  " 0 !face
  155.     ."    begin and end event definitions" scr
  156.     2 !face ."    ,S  " 0 !face
  157.     ."            compile (or stack) 4 bytes from ASCII" cr scr
  158.     2 !face  ."    +Md  " 0 !face ." variables:" scr
  159.     ."            136    Apple Event handler routine" scr
  160.     ."            188    Address of installation list" scr
  161.     ."            190    Error handler routine ("
  162.                          2 !face ." drop "  0 !face ." )" scr
  163.     ."            198    Reply record handle holder" scr
  164.     ."            202    Apple Event record handle" cr scr
  165.     ."    See the example program AppleEvents for more."
  166.     .arrows ;
  167.  
  168. : P9  cls scr
  169.     ."  • Use " 2 !face ." ?gestalt  " 0 !face
  170.        ." to query the system." cr scr
  171.     ."    Using this new system trap, available since" scr
  172.     ."    late system 6, you can determine much about" scr
  173.     ."    the system software and hardware."  scr scr
  174.     ."  • A color consious window is created if a" scr
  175.     ."    color machine is in use. This has no visual" scr
  176.     ."    effect but allows your programs to use color." scr scr
  177.     ."  • A new color icon and signature is used."
  178.     .arrows ;
  179.  
  180. : P10  cls scr
  181.     ." Bug fixes:" cr scr
  182.     ."  • The manual has been updated and now" scr
  183.     ."    prints with pictures, without errors." cr scr
  184.     ."  • " 2 !face ." Back  " 0 !face
  185.        ." now compiles correct branches." cr scr
  186.     ."  • A 32 bit address error in the update" scr
  187.     ."    routine has been fixed." cr scr
  188.     ."  • A new word, " 2 !face ." Bye  " 0 !face
  189.        ." does not use _ExitToShell."
  190.     .arrows ;
  191.  
  192. : P11  cls scr
  193.     ." Notes:" cr scr
  194.     ."  • Choosing “Save” from the menu confirms your" scr
  195.     ."    choice before overwriting the dictionary." cr scr
  196.     ."  • " 2 !face ." Grow  " 0 !face
  197.        ." is gone, the dictionary is always 32K." cr scr
  198.     ."  • 68040's instruction cache must be disabled." cr scr
  199.     ."  • " 2 !face ." +Loop  " 0 !face
  200.        ." works only with positive arguments." scr scr scr scr
  201.     ."                                ( continued ... )"
  202.     .arrows ;
  203.  
  204. : P12  cls scr
  205.     ." Notes, continued ..." cr scr
  206.     ."  • The floating point interpreter will" scr
  207.     ."    attempt to convert any non-defined" scr
  208.     ."    token to a number." cr scr
  209.     ."  • A DA version is not included. Bug fixes" scr
  210.     ."    are available for version 1.5."
  211.     .arrows ;
  212.  
  213. : P13  cls scr
  214.     ." Packing list for Pocket Forth, release 6:" cr scr
  215.     ."  • The application, Pocket Forth" scr
  216.     ."  • The Pocket Forth Manual parts 1 and 2" scr
  217.     ."  • The Glossary of Pocket Forth words" scr
  218.     ."  • Source code with assembly instructions" cr scr
  219.     ."  • Ten example files:" scr
  220.     ."    AppleEvents      (with HyperCard stack)" scr
  221.     ."    Reader              create this stand alone application"
  222.     scr scr scr ."                                ( continued ... )"
  223.     .arrows ;
  224.  
  225. : P14  cls scr
  226.     ." Examples continued ..." cr scr
  227.     ."    TextEdit              the guts of a text editor" scr
  228.     ."    Sieve                   the Sieve of Erastothanes" scr
  229.     ."    Window&Menu   demonstrate them" scr
  230.     ."    DataFiles            read and write ASCII data files" scr
  231.     ."    SANETrig             floating point trig. functions" scr
  232.     ."    IntegerTrig         16/32 bit math functions" scr
  233.     ."    Graphics             library of QuickDraw routines" scr
  234.     ."    Misc                    library of utility routines"
  235.     .arrows ;
  236.  
  237. : P15  cls scr
  238.     ."    If you find a bug, need help, or want to talk" scr
  239.     ."    about this, write. I'd like to hear from you and" scr
  240.     ."    I'll attempt to answer your mail." cr scr
  241.     ."    Do not send any money, Pocket Forth is free!" cr scr
  242.     ."    Contact me at any of the following addresses:" scr
  243.     ."      CompuServe     [70566,1474]" scr
  244.     ."      AOL                   cheilman" scr
  245.     ."      Email                “heilman@pc.maricopa.edu”" scr
  246.     ."      U.S. Mail           PO box 8345" scr
  247.     ."                               Phoenix AZ 85066-8345"
  248.     .aarrow ;
  249.  
  250. variable PWHICH  0 pwhich !  ( page-1 to be drawn )
  251. 14 constant PNO  ( number of pages-1 )
  252. create PLIST  ( ordered list of routines or "pages" )
  253.     ' p1 ,  ' p2 ,  ' p3 ,  ' p4 ,
  254.     ' p5 ,  ' p6 ,  ' p7 ,  ' p8 ,
  255.     ' p9 ,  ' p10 , ' p11 ,  ' p12 ,
  256.     ' p13 ,  ' p14 ,  ' p15 ,
  257.  
  258. ( menu, button and event handlers )
  259. : DOUP  pwhich @ 2* plist + @ execute ;  ( draw the pwhichth page )
  260. : DOAFT  pwhich @ 1 - 0 max pwhich ! doup ;  ( decrement pwhich )
  261. : DOFOR  pwhich @ 1+ pno min pwhich ! doup ;  ( increment pwhich )
  262. : DOFIRST  0 pwhich ! doup ;  ( go to first page )
  263. : DOLAST  pno pwhich ! doup ;  ( go to last page )
  264. : DOBUTT  ( -- ) ( button handler )
  265.     @mouse apoly ?phit IF apoly 2@ 2>r ,$ A8C9 doaft ELSE
  266.       @mouse fpoly ?phit IF fpoly 2@ 2>r ,$ A8C9  dofor 
  267.     THEN  THEN ;
  268.  
  269. ( old style colors )
  270. : BLACK    33 0 2>r ,$ A862 ;  ( black _ForeColor )
  271. : RED     205 0 2>r ,$ A862 ;  ( red _ForeColor )
  272.  
  273. ( create and destroy pictures )
  274. : PICTURE ( rect -- dhandle ) ( open a picture )
  275.     0 0 2>r  a>r  ,$ A8F3 2r> ;  ( _OpenPicture )
  276. : PCLOSE ,$ A8F4 ; macro  ( _ClosePicture )
  277. : PKILL ( addr -- ) 2@ 2>r ,$ A8F5 ; ( _KillPicture at addr )
  278. : PDRAW ( rect dhandle -- ) ( draw a picture in rect )
  279.     2>r a>r ,$ A8F6 ;  ( _DrawPicture )
  280.  
  281. rect BRECT  ( the bird's rect )
  282. rect OBRECT  ( old brect )
  283. 2variable B1PICT  ( hold b1's pict handle )
  284. 2variable B2PICT  ( hold b2's pict handle )
  285. 2variable B3PICT  ( hold b3's pict handle )
  286.  
  287. ( draw the three bird positions )
  288. : .B1  red 2 0 !pen 6 0 -to 12 6 -to 18 0 -to 22 0 -to  black ;
  289. : .B2  red 0 6 !pen 24 6 -to black ;
  290. : .B3  red 2 12 !pen 6 12 -to 12 6 -to 18 12 -to 22 12 -to black ;
  291.  
  292. : BNEW  brect picture .b1 pclose b1pict 2!
  293.     brect picture .b2 pclose b2pict 2!
  294.     brect picture .b3 pclose b3pict 2! ;
  295. : BKILL  b1pict pkill b2pict pkill b2pict pkill ;
  296.  
  297. : B1 brect b1pict 2@ pdraw ;
  298. : B2 brect b2pict 2@ pdraw ;
  299. : B3 brect b3pict 2@ pdraw ;
  300. create .BS  ' b1 ,  ' b2 ,  ' b3 ,  ( bird draw array )
  301. variable BTHIS  0 bthis !  ( offset to the current routine )
  302.  
  303. : XLATE 3 -1 brect roffset ;  ( translate brect )
  304. : INSET 1 1 brect rinset ;  ( shrink brect )
  305.  
  306. : ANIMATE ( -- ) ( draw the current bird, etc. )
  307.     brect ?empty IF  ( if the bird has shrunk to oblivion  ... )
  308.       48 291 60 309 brect !rect  THEN  ( ... restore its origonal size )
  309.     obrect rerase  ( erase the old bird )
  310.     brect @rect obrect !rect  ( set the old bird to the current bird )
  311.     0 -1 obrect rinset  ( expand the old birds rect )
  312.     bthis @  ( get the current bird offset )
  313.     dup .bs + @  execute  ( execute the address of the draw bird routine )
  314.     4 < IF  ( if its bird 1 or 2 )
  315.       2 bthis +!  xlate  ( increment bird offset and move the bird's rect )
  316.     ELSE  ( its bird 3 )
  317.       0 bthis !  xlate inset  ( set bird 1, move and shrink bird's rect )
  318.       2 >r ,$ A889  ( SrcXor _TextMode )
  319.       50 30 !pen ." NEW!   IMPROVED!"  ( flip the title )
  320.     THEN ;
  321.  
  322. variable TLAST  0 tlast !  ( timer )
  323. 10 constant DELAY
  324. : TICKS ( -- n ) 364 0 l@ ;
  325. : ?TIME ( -- flags ) ( true if 1/delay seconds has elapsed )
  326.     ticks tlast @ - abs delay > ;
  327. : DOIDLE  ( do the birdie animation )
  328.     pwhich @ 0= IF  ( if its the title page )
  329.       ?time IF ticks tlast ! animate
  330.     THEN  THEN ;
  331.  
  332. : STOP  bkill bye ;
  333.  
  334. ( set menu handlers )
  335. create GMENU ' dofirst , ' doaft , ' dofor , ' dolast ,
  336. create FMENU ' stop ,
  337. create MBAR fmenu ,  18 +md @ 2+ @ ,  gmenu ,
  338. 2variable GMENUH  0 0 gmenuh 2!  ( holder for goMenuHandle )
  339. ' beep  18 +md @  ( get pointer to menu list )
  340.         2+ @  ( get pointer to Edit menu from menu list )
  341.         8 + !  ( set paste handler to beep )
  342.  
  343. : +MENU ( -- ) ( Turn the new menu on.)
  344.     0 0 2>r 4 >r ,$ A9BF  ( _GetRMenu )
  345.     2r> 2dup 2>r 0 >r ,$ A935  ( _InsertMenu )
  346.     gmenuh 2!  ,$ A937 ;  ( _DrawMenuBar )
  347.  
  348. : START  +menu  *apoly *fpoly  sfont
  349.     0 0 14 28 brect !rect  bnew
  350.     0 0 0 0 brect !rect
  351.     0 0 0 0 obrect !rect 
  352.     BEGIN key drop AGAIN ;  ( event loop )
  353.  
  354. ( set event/message handlers )
  355. ' doup    14 +md !  ( set update handler )
  356. ' dobutt  16 +md !  ( set button handler )
  357.   mbar    18 +md !  ( set the menu handlers )
  358. ' doidle  20 +md !  ( set idle handler )
  359. ' stop    22 +md !  ( set quit handler )
  360. ' start   26 +md !  ( set startup handler )
  361. ' null   136 +md !  ( disable Apple Events )
  362. 450 250    8 +md 2!  ( set window size )
  363.  
  364. save  bye  ( save and quit )
  365.